home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / 8.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  63KB  |  2,172 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #ifndef SEM
  10. #define SEM    1
  11. #endif
  12.  
  13. #include "hdr.h"
  14. #include "vars.h"
  15. #include "attr.h"
  16. #include "dclmapp.h"
  17. #include "errmsgp.h"
  18. #include "sspansp.h"
  19. #include "nodesp.h"
  20. #include "setp.h"
  21. #include "miscp.h"
  22. #include "smiscp.h"
  23. #include "chapp.h"
  24.  
  25. /*
  26.  CHECK HANDLING OF NEW_NAME in newmod    ds 30 jul
  27.  Sort out is_identifier usage        ds 26 nov 84
  28.  Bring C version of find_simple_name in closer correspondence to SETL
  29.  version.    ds 7 aug 84
  30.  
  31.  Note that set imported in collect_imported names is built on every call.
  32.  It is probably dead on return, but I am not copying it when I put in
  33.  in all_imported_names. May be able to do set_free(imported) before
  34.  return from collect_imported_names - look into this later.  ds 2 aug
  35. */
  36.  
  37. /*
  38.  * The following global variable is used for error reporting when
  39.  * several instances of an identifier end up hiding each other and
  40.  * the identifier is seen as undeclared or ambiguous.
  41.  */
  42. static Set all_imported_names; /*TBSL: initialize to (Set)0 */
  43.  
  44.  
  45. static Set collect_imported_names(char *);
  46. static void name_error(Node);
  47. static void find_simple_name(Node);
  48. static void array_or_call(Node);
  49. static int parameterless_callable(Symbol);
  50. static void index_or_slice(Node);
  51. static void find_selected_comp(Node);
  52. static void find_exp_name(Node, Symbol, char *);
  53. static void all_declarations(Node, Symbol, char *, Symbol);
  54. static int has_implicit_operator(Node, Symbol, char *);
  55. static void make_any_id_node(Node);
  56. static int is_appropriate_for_record(Symbol);
  57. static int is_appropriate_for_task(Symbol);
  58. static Symbol renamed(Node, Tuple, Symbol);
  59. static Symbol op_matches_spec(Symbol, Tuple, Symbol);
  60. static void check_modes(Tuple, Symbol);
  61. static void renamed_entry(Node, Tuple);
  62.  
  63. void find_old(Node id_node)                                    /*;find_old*/
  64. {
  65.     /*
  66.      * Establish unique name of identifier, or of syntactic category name.
  67.      * Yield error in the case of undefined identifier.
  68.      * In the case of long and short integers, indicate that they are
  69.      * unimplemented rather than 'undefined'.
  70.      */
  71.     Symbol    u_name;
  72.     char    *id;
  73.     char    *newn;
  74.     int        unsupported;
  75.  
  76.     if (cdebug2 > 3)
  77.         TO_ERRFILE("AT PROC :  find_old");
  78.  
  79.     check_old(id_node);
  80.     if (N_KIND(id_node) != as_simple_name) return; /* added 7 jul */
  81.     u_name = N_OVERLOADED(id_node) ? (Symbol) 0 : N_UNQ(id_node);
  82.     id = N_VAL(id_node);
  83.     if (u_name == symbol_undef) {
  84.         if (streq(id, "LONG_INTEGER") || streq(id, "SHORT_INTEGER")) {
  85.             unsupported = TRUE;
  86.             u_name = symbol_integer; /* new type to use */
  87.         }
  88.         else if (streq(id, "SHORT_FLOAT") || streq(id, "LONG_FLOAT")) {
  89.             unsupported = TRUE;
  90.             u_name = symbol_float; /* new type to use */
  91.         }
  92.         else {
  93.             unsupported = FALSE;
  94.         }
  95.  
  96.         if (!unsupported) {
  97.             /* The identifier is undefined, or not visible. This is an error.*/
  98.             name_error(id_node);
  99.         }
  100.         else {
  101.             /* The identifier names unsupported type. This is error, so
  102.              * issue error message and then change type to avoid further
  103.              * spurious error messages
  104.              */
  105.             errmsg_str("% is not supported in current implementation",
  106.               id, "none", id_node);
  107.             N_UNQ(id_node) = u_name;
  108.             return;
  109.         }
  110.         /* insert in current scope, and give it default type.*/
  111.         if (dcl_get(DECLARED(scope_name), id) == (Symbol)0
  112.           && set_size(all_imported_names) == 0) {
  113.             newn = id;
  114.             u_name = find_new(newn);
  115.             NATURE(u_name)    = na_obj; /* Could be more precise.*/
  116.             N_UNQ(id_node) = u_name;
  117.         }
  118.         TYPE_OF(u_name) = symbol_any;
  119.         ALIAS(u_name) = symbol_any;
  120.     }
  121. }
  122.  
  123. Symbol find_type(Node node) /*;find_type*/
  124. {
  125.     Symbol    type_mark;
  126.  
  127.     /* Resolve a name that must yield a type mark.*/
  128.     find_old(node);
  129.     type_mark = N_UNQ(node);
  130.     if (N_OVERLOADED(node) || type_mark == (Symbol)0
  131.       || !is_type(type_mark) && TYPE_OF(type_mark) != symbol_any) {
  132.         errmsg("Invalid type mark ", "none", node);
  133.         N_UNQ(node) = type_mark = symbol_any;
  134.     }
  135.     return type_mark;
  136. }
  137.  
  138. static void name_error(Node id_node)  /*;name_error*/
  139. {
  140.  
  141.     char    *id;
  142.     char    *names;
  143.  
  144.     if (cdebug2 > 3)
  145.         TO_ERRFILE("AT PROC :  name_error");
  146.     /*
  147.      * Name was not found in environment. This may be because it is undeclared,
  148.      * or because several imported instances of the name hide each other.
  149.      * The marker '?' is also returned when a type name is mentioned in
  150.      * the middle of its own elaboration.
  151.      */
  152.     id = N_VAL(id_node);
  153.     if (set_size(all_imported_names) == 0) {
  154.         if (dcl_get(DECLARED(scope_name), id) == (Symbol)0) {
  155.             errmsg_str("identifier undeclared or not visible %", id, "3.1", id_node);
  156.         }
  157.         else {
  158.             errmsg_str("Invalid reference to %", id , "3.3", id_node);
  159.         }
  160.     }
  161.     else {
  162. #ifdef TBSL
  163.         names = +/[ original_name(scope_of(x)) + '.' + original_name(x)
  164.             + ' ':    x in all_imported_names ];
  165. #endif
  166.         names = build_full_names(all_imported_names);
  167.         errmsg_str("Ambiguous identifier. Could be one of: %",
  168.           names, "8.3, 8.4", id_node);
  169.     }
  170. }
  171.  
  172. void check_old(Node n_node)  /*;check_old*/
  173. {
  174.     Node    node, attr, arg1, expn;
  175.     int    nk;
  176.  
  177.     if (cdebug2 > 3) {
  178.         TO_ERRFILE("AT PROC :  check_old");
  179.         printf("  kind %s\n", kind_str(N_KIND(n_node))); /*DEBUG*/
  180.     }
  181.     /*
  182.      * This procedure performs name resolution for several syntactic
  183.      * instances of names. These include identifiers, selected components,
  184.      * array indexing and slicing, function calls and attribute expressions.
  185.      * If -name- is an identifier and is undeclared, this proc yields
  186.      * the special marker '?' which is used by error routines.
  187.      * If -name- is overloaded, the procedure returns the set of overloaded
  188.      * names which correspond to -name-. This set is constructed by
  189.      * scanning first the open scopes, and then examining visible packages.
  190.      * To facilitate the collection of overloaded names, the procedure
  191.      * chain_overload, which is called when a procedure specification, or
  192.      * and enumeration type are processed, collects successive overloads of the
  193.      * same id together, using the -overloads- field of the symbol table.
  194.      */
  195.  
  196.     switch (nk = N_KIND(n_node)) {
  197.       case    as_simple_name:
  198.       case    as_character_literal:
  199.       case    as_package_stub:
  200.       case    as_task_stub:
  201.                 find_simple_name(n_node);
  202.                 break;
  203.       case    as_call_unresolved:
  204.                 array_or_call(n_node);
  205.                 break;
  206.       case    as_selector:
  207.                 find_selected_comp(n_node);
  208.                 break;
  209.       case    as_string:
  210.                 N_KIND(n_node) = as_simple_name; /* Treat as simple*/
  211.                 find_simple_name(n_node);            /* name.*/
  212.                 break;
  213.       case    as_name:
  214.       case    as_range_expression:
  215.                 node = N_AST1(n_node);
  216.                 find_old(node);
  217.                 copy_attributes(node, n_node);
  218.                 break;
  219.       case    as_attribute:
  220.                 attr = N_AST1(n_node);
  221.                 arg1 = N_AST2(n_node);
  222.                 find_old(arg1);
  223.                 break;
  224.       case    as_all:
  225.                 expn = N_AST1(n_node);
  226.                 find_old(expn);
  227.                 break;
  228.     }
  229. }
  230.  
  231. static void find_simple_name(Node n_node)        /*;find_simple_name*/
  232. {
  233.     char    *id;
  234.     Symbol    sc;
  235.     int        sc_num;
  236.     Symbol    u_name, o, n, u_n;
  237.     Symbol    found, foreign;
  238.     Set        names, names_add, found_set;
  239.     Set imported;
  240.     int        i, exists, found_is_set;
  241.     Forset    fs1, fs2;
  242.     Symbol    sym;
  243.  
  244.     id = N_VAL(n_node);
  245.  
  246.     if (cdebug2 > 0) {
  247.         TO_ERRFILE(" looking for id. " );
  248.         printf("  kind %s %s\n", kind_str(N_KIND(n_node)), id); /*DEBUG*/
  249.     }
  250.  
  251.     exists = FALSE;
  252.     for (sc_num = 1; sc_num <= tup_size(open_scopes); sc_num++) {
  253.         sc = (Symbol)open_scopes[sc_num];
  254.         u_name = dcl_get(DECLARED(sc), id);
  255.         if     (u_name != (Symbol)0) {
  256.             exists = TRUE;
  257.             break;
  258.         }
  259.     }
  260.     if (exists) {
  261.         if (!can_overload(u_name)) {
  262.             found_is_set = FALSE;
  263.             found = u_name;
  264.             TO_XREF(u_name);
  265.         }
  266.         else {
  267.             names = set_copy(OVERLOADS(u_name));
  268.  
  269.             /* Scan open scopes for further overloadings.*/
  270.             for (i = sc_num+1; i <= tup_size(open_scopes); i++) {
  271.                 u_n = dcl_get(DECLARED(((Symbol)open_scopes[i])), id);
  272.                 if (u_n == (Symbol)0) continue;
  273.                 else if (!can_overload(u_n)) {
  274.                     found_is_set = TRUE;
  275.                     found_set = names;
  276.                 }
  277.                 else {
  278.                     names_add = set_new(0);
  279.                     FORSET(o=(Symbol), OVERLOADS(u_n), fs1);
  280.                         exists = FALSE;
  281.                         FORSET(n=(Symbol), names, fs2);
  282.                             if (same_type(TYPE_OF(n), TYPE_OF(o)) &&
  283.                               same_signature(n, o)) {
  284.                                 exists = TRUE;
  285.                                 break;
  286.                             }
  287.                         ENDFORSET(fs2);
  288.                         if (!exists) names_add = set_with(names_add, (char *)o);
  289.                     ENDFORSET(fs1);
  290.                     FORSET(o=(Symbol), names_add, fs1);
  291.                         names = set_with(names, (char *)o);
  292.                     ENDFORSET(fs1);
  293.                     set_free(names_add);
  294.                 }
  295.             }
  296.             imported = collect_imported_names(id);
  297.             /* Keep only the imported names which are not hidden
  298.              * by visible names with the same signature.
  299.              */
  300.             if (set_size(imported)>1 ||
  301.               (set_size(imported) == 1 &&
  302.               can_overload((Symbol)set_arb(imported)))) {
  303.                 names_add = set_new(0);
  304.                 FORSET(foreign=(Symbol), imported, fs1);
  305.                     exists = FALSE;
  306.                     FORSET(n=(Symbol), names, fs2);
  307.                         if (same_type(TYPE_OF(n), TYPE_OF(foreign)) &&
  308.                             same_signature(n, foreign)) {
  309.                             exists = TRUE;
  310.                             break;
  311.                         }
  312.                         ENDFORSET(fs2);
  313.                     if (!exists)
  314.                         names_add = set_with(names_add, (char *)foreign);
  315.                 ENDFORSET(fs1);
  316.                 FORSET(n=(Symbol), names_add, fs1);
  317.                     names = set_with(names, (char *) n);
  318.                 ENDFORSET(fs1);
  319.                 set_free(names_add);
  320.             }
  321.             found_is_set = TRUE;
  322.             found_set = names;
  323.         }
  324.     }
  325.     else if ((imported = collect_imported_names(id) , set_size(imported)) != 0){
  326.         if (set_size(imported)>1 || can_overload((Symbol)set_arb(imported))) {
  327.             found_is_set = TRUE;
  328.             found_set = imported;
  329.         }
  330.         else {
  331.             found_is_set = FALSE;
  332.             found = (Symbol) set_arb(imported);
  333.         }
  334.     }
  335.     /* the syntactic error recovery routine sends a '' when it can
  336.      * recover by token insertion. return it as is, to avoid
  337.      * subsequent spurious messages.
  338.      */
  339.     /* #if DEAD */
  340.     /* DEAD (as best we can tell  7 jul */
  341.     else if (streq(id, "any_id")) {
  342.         found_is_set = FALSE;
  343.         found = symbol_any_id;
  344.     }
  345. #ifdef DEAD
  346.     else if (id == (Symbol)0) {
  347.         found_is_set = FALSE;
  348.         found = id;
  349.     }
  350. #endif
  351.     else {
  352.         found_is_set = FALSE;
  353.         found = symbol_undef; /* need to add symbol_undef '?' */
  354.     }
  355.     if (found_is_set) {
  356.         N_OVERLOADED(n_node) = TRUE;
  357.         N_NAMES(n_node) = found_set;
  358.     }
  359.     else {
  360.         N_OVERLOADED(n_node) = FALSE;
  361.         N_UNQ(n_node) = found;
  362.     }
  363.     if (cdebug2 == 0) return; /* rest is debugging trace only*/
  364.  
  365.     if (cdebug2 > 0) TO_ERRFILE ("found name(s): " );
  366. /* always print found names */
  367.     if (found_is_set) {
  368.         FORSET(sym=(Symbol), found_set, fs1)
  369. #ifdef IBM_PC
  370.             printf("%p", sym);
  371. #else
  372.         printf("%ld", sym);
  373. #endif
  374.         if (sym!=(Symbol)0) printf("%s", ORIG_NAME(sym));
  375.         printf("\n");
  376.         ENDFORSET(fs1);
  377.     }
  378.     else {
  379. #ifdef IBM_PC
  380.         printf("found name %p  ", found);
  381. #else
  382.         printf("found name %ld  ", found);
  383. #endif
  384.         /* symbol_undef should not need special handling  ds 17 jul
  385.         if (found == symbol_undef) printf("?\n");
  386.         else
  387.  */
  388.         if (found!=(Symbol)0) printf("%s\n", ORIG_NAME(found));
  389.     }
  390. }
  391.  
  392. static Set collect_imported_names(char *id)        /*;collect_imported_names*/
  393. {
  394.     Set imported;
  395.     Symbol    used;
  396.     Symbol    s;
  397.     Symbol    foreign;
  398.     Fortup    ft1;
  399.     Forset    fs1;
  400.  
  401.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  collect_imported_names");
  402.     /*
  403.      * This procedure collects the set of all imported names corresponding
  404.      * to identifier -name-, which appear in currently visible package.
  405.      * An imported identifier is visible if :
  406.      * a) It is not an overloadable identifier, and it appears in only
  407.      * one used package.
  408.      * b) Or, all of its appearances in used modules are overloadable.
  409.      */
  410.     imported = set_new(0);
  411.     /*
  412.      * (forall used in used_mods | (f:= visible(used)) /= om
  413.      *                 and (foreign := f(id)) /= om )
  414.      */
  415.     FORTUP(used=(Symbol), used_mods, ft1);
  416.         if (DECLARED(used) == (Declaredmap)0) continue;
  417.         foreign = dcl_get_vis(DECLARED(used), id);
  418.         if (foreign !=(Symbol)0) {
  419.             if (can_overload(foreign)){
  420.                 FORSET(s=(Symbol), OVERLOADS(foreign), fs1);
  421.                     imported = set_with(imported, (char *)s);
  422.                 ENDFORSET(fs1);
  423.             }
  424.             else {
  425.                 if (set_size(imported) != 0) {
  426.                     /* mutual hiding. Save all for error message.*/
  427.                     /* imported dead - no need to copy    ds 2 aug */
  428.                     all_imported_names = imported;
  429.                     all_imported_names = set_with(all_imported_names,
  430.                       (char *) foreign);
  431.                     return set_new(0);
  432.                 }
  433.                 else {
  434.                     imported = set_new1((char *) foreign);
  435.                 }
  436.             }
  437.         }
  438.     ENDFORTUP(ft1);
  439.  
  440.     if (cdebug2 > 1) TO_ERRFILE("Imported names:");
  441.  
  442.     /* Save imported names in global variable, for possible error message.*/
  443.     all_imported_names = imported;
  444.     return imported;
  445. #ifdef TBSL
  446.     -- this code seems to be dead  review this with Ed  ds    12-dec-84
  447.         exists = FALSE;
  448.     FORSET(fgn=(Symbol), imported, fs1);
  449.         if (!can_overload(fgn)) {
  450.             exists = TRUE;
  451.             break;
  452.         }
  453.     ENDFORSET(fs1);
  454.     if (exists) {
  455.         /* If it is the only name found, return it.*/
  456.         if (set_size(imported) == 1) {
  457.             /*set_free(imported);*/
  458.             return set_new1(fgn);
  459.         }
  460.         else {
  461.             /*set_free(imported);*/
  462.             return set_new(0);
  463.             /* various visible names hide each other.*/
  464.         }
  465.     }
  466.     else {
  467.         /* All occurrences are overloadable. Return only those which do*/
  468.         if (cdebug2 > 1) {
  469.             TO_ERRFILE("Names:");
  470.             return imported;
  471.         }
  472.     }
  473. #endif
  474. }
  475.  
  476. static void array_or_call(Node n_node)    /*;array_or_call*/
  477. {
  478.     /*
  479.      * This procedure resolves the construct
  480.      *    name aggregate
  481.      * The meaning of this construct is one of the following :
  482.      * a) Indexed expression or slice.
  483.      * b) function call.
  484.      * d) Conversion.
  485.      */
  486.  
  487.     Node    prefix_node, agg_node, call_node, index_node, p_node;
  488.     Tuple    arg_list;
  489.     Set        f_names, npfs;
  490.     Symbol    f, t;
  491.     Forset    fs1;
  492.  
  493.     if (cdebug2 > 3)
  494.         TO_ERRFILE("AT PROC :  array_or_call");
  495.  
  496.     prefix_node = N_AST1(n_node);
  497.     agg_node = N_AST2(n_node);
  498.     arg_list = N_LIST(agg_node);
  499.  
  500.     /* Find unique name of object (procedure, array, etc).*/
  501.     find_old(prefix_node);
  502.     /*  Need different error flag. */
  503.     if (N_UNQ(prefix_node) == (Symbol)symbol_undef)
  504.         /* error message emitted already by find_old.*/
  505.         return;
  506.  
  507.     if (N_OVERLOADED(prefix_node)) {
  508.         f_names = N_NAMES(prefix_node);
  509.         /* function call.*/
  510.         N_KIND(n_node) = as_call;
  511.         /* The  nature of at least one  of the  overloaded instances     must be
  512.          * callable.     This  is  checked  by the type resolution  routines. An
  513.          * unpleasant syntactic ambiguity appears if parameterless  functions
  514.          * that  return an  array type appear  in obj_name. In this    case the
  515.          * expression must  be reformatted  as an indexing on the result of a
  516.          * function    call. If  both parameterless  and  parametered functions
  517.          * are present, then the  tree itself is ambiguous, and both parsings
  518.          * must be carried, to be resolved by the type resolution routines.
  519.          */
  520.         npfs = set_new(0);
  521.         FORSET(f=(Symbol), f_names, fs1);
  522.             t = TYPE_OF(f);
  523.             if (parameterless_callable(f) && (is_array(t)
  524.               || is_access(t) && is_array((Symbol)designated_type(t))))
  525.                 npfs = set_with(npfs, (char *)f);
  526.         ENDFORSET(fs1);
  527.         if (set_size(npfs) != 0) {
  528.             index_or_slice(n_node);
  529.  
  530.             if (N_KIND(n_node) == as_slice) {
  531.                 /* no ambiguity: it must be a slice.*/
  532.                 ; }
  533.             else {
  534.                 /* Construct subtrees with both parsings.*/
  535.                 call_node  = copy_node(n_node);
  536.                 N_KIND(call_node) = as_call;
  537.                 index_node = copy_tree(n_node);
  538.                 p_node = N_AST1(index_node);
  539.                 N_NAMES(p_node) = npfs;
  540.                 N_OVERLOADED(p_node)= TRUE;
  541.  
  542.                 N_KIND(n_node) = as_call_or_index;
  543.                 N_AST1(n_node)  = call_node;
  544.                 N_AST2(n_node)  = index_node;
  545.             }
  546.         }
  547.     }
  548.     else if (is_type(N_UNQ(prefix_node))) {
  549.         /* Case of a conversion.*/
  550.         N_KIND(n_node) = as_convert;
  551.         if (tup_size(arg_list) == 1) {
  552.             /* Conversion of a single expression. $$$ What about a choice?*/
  553.             N_AST1(n_node) = prefix_node;
  554.             N_AST2(n_node) = (Node)arg_list[1];
  555.         }
  556.         else {
  557.             /* Conversion of an aggregate: label it as such.*/
  558.             N_KIND(agg_node) = as_aggregate;
  559.         }
  560.     }
  561.     else{
  562.         index_or_slice(n_node);
  563.     }
  564. }
  565.  
  566. static int parameterless_callable(Symbol f)   /*;parameterless_callable*/
  567. {
  568.     /*
  569.      * Assert  that f is  a parameterless function, or  that default values
  570.      * exist for all its parameters and it can be called without arguments.
  571.      */
  572.  
  573.     Symbol    formal;
  574.     Fortup    ft1;
  575.  
  576.     if (NATURE(f) !=na_function && NATURE(f)!=na_function_spec)
  577.         return FALSE;
  578.     FORTUP(formal=(Symbol), SIGNATURE(f), ft1);
  579.         if ((Node)default_expr(formal) == OPT_NODE ) return FALSE;
  580.     ENDFORTUP(ft1);
  581.     return TRUE;
  582. }
  583.  
  584. static void index_or_slice(Node n_node)     /*;index_or_slice*/
  585. {
  586.     /*
  587.      * A slice is not always recognizable syntactically from an
  588.      * indexing expression. v(arg) is a slice in 3 cases:
  589.      * a) arg is a range : L..R
  590.      * b) arg is of the form V'RANGE
  591.      * c) arg is a type mark, possibly with a range constraint.
  592.      */
  593.     Node    prefix_node, index_node, constraint;
  594.     Tuple    index_list;
  595.     int        index_kind;
  596.     Node    index;
  597.  
  598.     prefix_node = N_AST1(n_node);
  599.     index_node = N_AST2(n_node);
  600.     index_list = N_LIST(index_node);
  601.     N_KIND(n_node) = as_index; /* most likely. */
  602.  
  603.     if (tup_size(index_list) == 1) {
  604.         index = (Node)index_list[1];
  605.         index_kind = N_KIND(index );
  606.         if (index_kind == as_subtype)
  607.             N_KIND(n_node) = as_slice;
  608.         else if (index_kind == as_range) {
  609.             /* Reformat it as subtype of unknown type.*/
  610.             constraint = copy_node(index);
  611.             N_KIND(index) = as_subtype;
  612.             N_AST1(index) = OPT_NODE;
  613.             N_AST2(index) = constraint;
  614.             N_KIND(n_node) = as_slice;
  615.         }
  616.         else if (index_kind == as_name) {
  617.             find_old(index);
  618.             if (is_type(N_UNQ(index)) || (N_KIND(index) == as_attribute
  619.               && ((int)attribute_kind(index) == ATTR_RANGE
  620.               ||  (int)attribute_kind(index) == ATTR_O_RANGE
  621.               ||  (int)attribute_kind(index) == ATTR_T_RANGE)))
  622.                 N_KIND(n_node) = as_slice;
  623.         }
  624.     }
  625. }
  626.  
  627. static void find_selected_comp(Node n_node) /*;find_selected_comp*/
  628. {
  629.     Node    prefix_node, s_node;
  630.     char    *selector;
  631.     Set        objset;
  632.     Symbol    prefix, prefix_type, u_n;
  633.     Forset    fs1;
  634.     int        prefix_nat;
  635.     Symbol    subp;
  636.     Span    save_span;
  637.  
  638.     if (cdebug2 > 3)
  639.         TO_ERRFILE("AT PROC :  find_selected_comp");
  640.  
  641.     prefix_node = N_AST1(n_node);
  642.     s_node      = N_AST2(n_node);
  643.     selector    = N_VAL(s_node);
  644.     save_span   = get_left_span(n_node);
  645.  
  646.     find_old(prefix_node);
  647.  
  648.     if (NATURE(scope_name) == na_void && streq(ORIG_NAME(scope_name), selector))
  649.         errmsg_str("premature usage of %", selector, "8.3(16)", s_node);
  650.  
  651.     if (N_KIND(prefix_node) == as_simple_name && !N_OVERLOADED(prefix_node)){
  652.         prefix = N_UNQ(prefix_node);
  653.         prefix_type = TYPE_OF(prefix);
  654.         prefix_nat = NATURE(prefix);
  655.         if (prefix_nat == na_package_spec || prefix_nat == na_package)
  656.             find_exp_name(n_node, prefix, selector);
  657.         else if (is_appropriate_for_record(prefix_type))  {
  658.             /* Type checking will verify that the selector denotes a
  659.              * discriminant or component of the corresponding record or value.
  660.              */
  661.             ;
  662.         }
  663.         else if (is_appropriate_for_task(prefix_type)
  664.             /* if the selector is an entry name, return it as as selected
  665.              * component.  Context is an entry call or the prefix of the
  666.              * attribute COUNT.
  667.              */
  668.           && (is_access(prefix_type)
  669.           || (((u_n= dcl_get(DECLARED(prefix_type), selector))!= (Symbol)0)
  670.           && (NATURE(u_n)  == na_entry || NATURE(u_n) == na_entry_family)))) {
  671.             ;
  672.         }
  673.         /* other forms of selected components are expanded names. */
  674.  
  675.         else if (in_open_scopes(prefix) && prefix_nat != na_void) {
  676.             /* prefix denotes an enclosing loop, block, or task, i.e. an
  677.              * enclosing construct that is not a subprogram or accept statement.
  678.               */
  679.             find_exp_name(n_node, prefix, selector);
  680.         }
  681.  
  682.         else {             /* various error cases. */
  683.             if (prefix_type == symbol_any) {
  684.                 /* Object was undeclared, and error message emitted already.*/
  685.                 ;
  686.             }
  687.             else if (NATURE(prefix) == na_void) {
  688.                 errmsg_id("premature usage of %", prefix, "8.3(16)", n_node);
  689.             }
  690.             else {
  691.                 errmsg("Invalid prefix in qualified name", "4.1.3", n_node);
  692.             }
  693.             make_any_id_node(n_node);
  694.         }
  695.         return;
  696.     }
  697.     if (N_KIND(prefix_node) != as_simple_name) {
  698.         /* if the prefix is not a simple name (overloaded or not) it must be
  699.           * be an expression whose type is appropriate for a record or access
  700.           * type. Its full resolution requires type resolution as well. Nothing
  701.           * else is done here.
  702.           */
  703.         ;
  704.         return;
  705.     }
  706.     objset= N_NAMES(prefix_node);
  707.  
  708.     /* At this point the prefix is an overloaded name. It can be an enclosing
  709.       * subprogram or accept statement. It can also be a call to a parameterless
  710.       * function that yields a record value.
  711.       */
  712.     FORSET(subp=(Symbol), objset, fs1);
  713.         if (in_open_scopes(subp )) {
  714.             /* TBSL: more than one visible such name. */
  715.             find_exp_name(n_node, subp, selector);
  716.             return;
  717.         }
  718.     ENDFORSET(fs1);
  719.  
  720.     /* if no interpretation as an expanded name is possible, it must be a
  721.       * selected component of a record returned by a function call.
  722.       */
  723.     FORSET(subp=(Symbol), objset, fs1);
  724.         if (parameterless_callable(subp))
  725.             return;
  726.     ENDFORSET(fs1);
  727.     /* nothing found.*/
  728.     make_any_id_node(n_node);
  729.     errmsg("Ambiguous name in selected component", "4.1.3", n_node);
  730. }
  731.  
  732. static void find_exp_name(Node n_node, Symbol prefix, char *selector)
  733.   /*;find_exp_name*/
  734. {
  735.     /* resolve an expanded name whose prefix denotes a package or an enclosing
  736.      * construct.
  737.      */
  738.  
  739.     Symbol    entity;
  740.  
  741.     if (in_open_scopes(prefix))
  742.         entity = dcl_get(DECLARED(prefix), selector);
  743.     else                    /* prefix is package. */
  744.         entity = dcl_get_vis(DECLARED(prefix), selector);
  745.     if (entity !=(Symbol)0)
  746.         /* If the object is overloaded, collect its local occurences.*/
  747.         all_declarations(n_node, prefix, selector, entity);
  748.     else if (has_implicit_operator(n_node, prefix, selector)) {
  749.         /* It can still be an implicitly defined operator obtained by derivation
  750.          * of a predefined type within the given construct.
  751.          */
  752.         ;
  753.     }
  754.     else {
  755.         make_any_id_node(n_node);
  756.         errmsg_str_id("% not declared in %" , selector,
  757.           prefix, "4.1.3, 8.3", n_node);
  758.     }
  759. }
  760.  
  761. static void all_declarations(Node n_node, Symbol prefix, char *selector,
  762.   Symbol entity) /*;all_declarations*/
  763. {
  764.     /* collect all declarations that overload an entity that is declared
  765.      * in a given construct. If the entity is not overloadable it is returned
  766.      * as is (a simple name). Otherwise the local overloading must also be
  767.      * collected. This is made complicated by the possible presence of implicit
  768.      * operators, which are created by the derivation of predefined types, but
  769.      * are nto inserted explicitly into the symbol table of the declarative
  770.      * part where they occur.
  771.      */
  772.  
  773.     int        forall, ii;
  774.     Symbol    predef_op, subp, f;
  775.     Forset    fs1;
  776.     Tuple    tup;
  777.     Set        nams;
  778.     Span    save_span;
  779.  
  780.     save_span = get_left_span(n_node);
  781.     N_KIND(n_node) = as_simple_name;    /* most likely case.*/
  782.     N_OVERLOADED(n_node) = FALSE;
  783.     if (can_overload(entity)) {
  784.         nams = set_copy(OVERLOADS(entity));
  785.         if( in_op_designators(selector) && prefix!=symbol_standard0 ){
  786.             /* Include implicitly defined operators, if they are not hidden by
  787.               * an explicit declaration in the scope. To determine whether it is
  788.               * hidden, compare it with the signature of the user-defined
  789.              *operator just as for the resolution of renamings.
  790.               */
  791.             predef_op = dcl_get(DECLARED(symbol_standard0), selector);
  792.             forall = TRUE;
  793.             FORSET(subp=(Symbol), nams, fs1);
  794.                 tup = tup_new(tup_size(SIGNATURE(subp)));
  795.                 for (ii = 1; ii <= tup_size(SIGNATURE(subp)); ii++) {
  796.                     f = (Symbol) ((SIGNATURE(subp))[ii]);
  797.                     tup[ii] = (char *)TYPE_OF(f);
  798.                 }
  799.                 if (!(op_matches_spec(predef_op, tup, TYPE_OF(subp))
  800.                    == (Symbol)0)) {
  801.                     forall = FALSE;
  802. #ifdef TUPFREE
  803.                     tup_free(tup);
  804. #endif
  805.                     break;
  806.                 }
  807. #ifdef TUPFREE
  808.                 tup_free(tup);
  809. #endif
  810.             ENDFORSET(fs1);
  811.             if (forall) {
  812.                 /* leave as qualified name, for resolution in
  813.                  * procedure result_types.
  814.                   */
  815.                 nams = set_with(nams, (char *)predef_op);
  816.                 N_KIND(n_node) = as_selector;
  817.             }
  818.         }
  819.         /* in any case, entity is overloaded.*/
  820.         N_OVERLOADED(n_node) = TRUE;
  821.         N_NAMES(n_node) = nams;
  822.     }
  823.     if (N_KIND(n_node) == as_simple_name) {
  824.         if (!N_OVERLOADED(n_node)) N_UNQ(n_node) = entity;
  825.         N_AST2(n_node) = (Node)0;
  826.         N_VAL(n_node) = selector;
  827.         set_span(n_node, save_span);
  828.         TO_XREF(entity);
  829.     }
  830. }
  831.  
  832. static int has_implicit_operator(Node n_node, Symbol scope, char *selector)
  833.   /*;has_implicit_operator*/
  834. {
  835.     Fordeclared fd1;
  836.     Symbol    root, typ;
  837.     char    *id;
  838.  
  839.     if (!in_op_designators(selector))
  840.         return FALSE;
  841.     FORDECLARED(id, typ, DECLARED(scope), fd1);
  842.         if (!is_type(typ)) continue;
  843.         root = root_type (typ);
  844.  
  845.         if ( !is_limited_type (typ)
  846.           && (streq(selector, "=") || streq(selector, "/="))) {
  847.             N_OVERLOADED(n_node) = TRUE;
  848.             N_NAMES(n_node) =
  849.               set_new1((char *)dcl_get(DECLARED(symbol_standard0), selector));
  850.             return TRUE;
  851.         }
  852.         if (((root == symbol_boolean) || (is_array (typ) &&
  853.           (root_type (component_type (typ)) == symbol_boolean))) &&
  854.           (streq(selector, "not") || streq(selector, "and")
  855.           || streq(selector, "or") || streq(selector, "xor"))) {
  856.             N_OVERLOADED(n_node) = TRUE;
  857.             N_NAMES(n_node) =
  858.               set_new1((char *)dcl_get(DECLARED(symbol_standard0), selector));
  859.             return TRUE;
  860.         }
  861.         if (is_scalar_type (typ) || (is_array (typ) &&
  862.           is_discrete_type (component_type (typ))) &&
  863.           (streq(selector, "<") || streq(selector, "<=")
  864.           || streq(selector, ">") || streq(selector, ">="))) {
  865.             N_OVERLOADED(n_node) = TRUE;
  866.             N_NAMES(n_node) =
  867.               set_new1((char *)dcl_get(DECLARED(symbol_standard0), selector));
  868.             return TRUE;
  869.         }
  870.         if (is_numeric_type (typ) &&
  871.           (streq(selector, "+") || streq(selector, "-") ||
  872.           streq(selector, "*") || streq(selector, "/") ||
  873.           streq(selector, "**") || streq(selector, "abs") ||
  874.           streq(selector, "mod") || streq(selector, "rem"))) {
  875.             N_OVERLOADED(n_node) = TRUE;
  876.             N_NAMES(n_node) =
  877.                set_new1((char *)dcl_get(DECLARED(symbol_standard0), selector));
  878.             return TRUE;
  879.         }
  880.         if (is_array (typ) && streq (selector , "&")) {
  881.             N_OVERLOADED(n_node) = TRUE;
  882.             N_NAMES(n_node) =
  883.               set_new1((char *)dcl_get(DECLARED(symbol_standard0), selector));
  884.             return TRUE;
  885.         }
  886.     ENDFORDECLARED(fd1);
  887.     return FALSE;
  888. }
  889.  
  890. static void make_any_id_node(Node n_node) /*;make_any_id_node*/
  891. {
  892.     Span    save_span;
  893.  
  894.     save_span = get_left_span(n_node);
  895.     N_KIND(n_node) = as_simple_name;
  896.     N_AST2(n_node) = (Node)0;
  897.     set_span(n_node, save_span);
  898.     N_UNQ(n_node) = symbol_any_id;
  899. }
  900.  
  901. static int is_appropriate_for_record(Symbol t) /*;is_appropriate_for_record*/
  902. {
  903.     return (is_record(t)
  904.         || is_access(t) && is_record(designated_type(t)));
  905. }
  906.  
  907. static int is_appropriate_for_task(Symbol t)        /*;is_appropriate_for_task*/
  908. {
  909.     return (is_task_type(t)
  910.         || is_access(t) && is_task_type(designated_type(t)));
  911. }
  912.  
  913. Set find_agg_types()   /*;find_agg_types*/
  914. {
  915.     /*
  916.      * The possible types of an aggregate  are all the structured types  that
  917.      * are    visible, even if  not directly    visible.
  918.      */
  919.  
  920.     Symbol    s, agg, p, fgn, ss;
  921.     Set    res;
  922.     Fortup    ft1;
  923.     Forset    fs1;
  924.  
  925.     /*
  926.      * return {}  +/[overloads(agg): s in open_scopes
  927.      *               |(agg := declared(s)('aggregate')) /= om]
  928.      *     +/[overloads(fgn) : p in vis_mods
  929.      *               |(fgn :=  visible(p)('aggregate')) /= om];
  930.      */
  931.     res = set_new(0);
  932.     FORTUP(s=(Symbol), open_scopes, ft1);
  933.         agg = dcl_get(DECLARED(s), "aggregate");
  934.         if (agg!=(Symbol)0) {
  935.             FORSET(ss=(Symbol), OVERLOADS(agg), fs1);
  936.                 res = set_with(res, (char *)ss);
  937.             ENDFORSET(fs1);
  938.         }
  939.     ENDFORTUP(ft1);
  940.     FORTUP(p=(Symbol), vis_mods, ft1);
  941.         fgn =  dcl_get_vis(DECLARED(p), "aggregate");
  942.         if (fgn!=(Symbol)0) {
  943.             FORSET(ss=(Symbol), OVERLOADS(fgn), fs1);
  944.                 res = set_with(res, (char *) ss);
  945.             ENDFORSET(fs1);
  946.         }
  947.     ENDFORTUP(ft1);
  948.     return res;
  949. }
  950.  
  951. Set find_access_types() /*;find_access_types*/
  952. {
  953.     /*
  954.      * Similarly, the possible types of NULL, and of any allocator, are all
  955.      * visible access types. To simplify their  retrieval, they are treated
  956.      * like aggregates,  and  attached to the marker  'access', whenever an
  957.      * access type definition is processed.
  958.      */
  959.  
  960.     Set a_types;
  961.     Symbol    s, fgn, ss, a;
  962.     Fortup    ft1;
  963.     Forset    fs1;
  964.  
  965.     /*
  966.      * a_types =
  967.      * {} +/[overloads(a): s in open_scopes
  968.      *               |(a := declared(s)('access')) /= om]
  969.      *   +/[overloads(fgn) : p in vis_mods
  970.      *               |(fgn :=  visible(p)('access')) /= om];
  971.      */
  972.     a_types = set_new(0);
  973.     FORTUP(s = (Symbol), open_scopes, ft1);
  974.         a = dcl_get(DECLARED(s), "access");
  975.         if (a != (Symbol)0) {
  976.             FORSET(ss=(Symbol), OVERLOADS(a), fs1);
  977.                 a_types = set_with(a_types, (char *) ss);
  978.             ENDFORSET(fs1);
  979.         }
  980.     ENDFORTUP(ft1);
  981.  
  982.     FORTUP(fgn = (Symbol), vis_mods, ft1);
  983.         fgn =  dcl_get_vis(DECLARED(fgn), "access");
  984.         if (fgn != (Symbol)0) {
  985.             FORSET(ss=(Symbol), OVERLOADS(fgn), fs1);
  986.                 a_types = set_with(a_types, (char *) ss);
  987.             ENDFORSET(fs1);
  988.         }
  989.     ENDFORTUP(ft1);
  990.  
  991.     if (set_size(a_types) == 0) {
  992.         noop_error = TRUE;
  993.         errmsg("No available access types for allocator", "3.8,4.8",
  994.             current_node);
  995.     }
  996.     return a_types;
  997. }
  998.  
  999. Symbol find_new(char *name)  /*;find_new*/
  1000. {
  1001.     Symbol    unique_nam, old;
  1002.  
  1003.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  find_new");
  1004.  
  1005.     /*
  1006.      * insert new name in symbol table of current scope. Check
  1007.      * against duplications.
  1008.      *
  1009.      * IF error token was seen ('') , return undeclared marker.
  1010.      */
  1011.  
  1012.     if (name == (char *)0 || strlen(name) == 0) return    symbol_any_id;
  1013.  
  1014.     /* add new name to current scope declarations.
  1015.      * generate a unique identifier for it.
  1016.      */
  1017.  
  1018.     unique_nam = (Symbol) 0;
  1019.  
  1020.     /* Insert new name in DECLARED table for current scope */
  1021.     old = dcl_get(DECLARED(scope_name), name);
  1022.     if (old     != (Symbol)0) {
  1023.         /* The name has been seen already. This is acceptable
  1024.          * if it  was inserted after     some previous    error of
  1025.          * any sort. (in that case it has type 'any').
  1026.          */
  1027.         if    (TYPE_OF(old) == symbol_any) return old;
  1028.         else {
  1029.             errmsg_str("duplicate identifier: %", name , "8.3", current_node);
  1030.         }
  1031.     }
  1032.     else {
  1033.         unique_nam = sym_new(na_void);
  1034.         /* insert in declared map for scope, and make visible if scope
  1035.           * is a package specification. ES 9-21-86)
  1036.           */
  1037.         dcl_put_vis(DECLARED(scope_name), name, unique_nam ,
  1038.           (NATURE(scope_name) == na_package_spec));
  1039.     }
  1040.     /* Initialize symbol table entry.*/
  1041.     /* allocate new symbol if not yet allocated */
  1042.     if (unique_nam == (Symbol)0) unique_nam = sym_new(na_void);
  1043.     NATURE(unique_nam)  = na_void;
  1044.     TYPE_OF(unique_nam)  = symbol_none;
  1045.     SCOPE_OF(unique_nam) = scope_name;
  1046.     ORIG_NAME(unique_nam) = name;
  1047.     TO_XREF(unique_nam);
  1048.     return unique_nam;
  1049. }
  1050.  
  1051. void check_void(char *id)  /*;check_void*/
  1052. {
  1053.     /*
  1054.      * Verify that within a procedure specification no use is made of the
  1055.      * procedure identifier under any guise. This cannot be automatically
  1056.      * caught by the name resolution routines.
  1057.      */
  1058.     if (streq(original_name(scope_name), id) && NATURE(scope_name) == na_void){
  1059.         errmsg_str("premature usage of %", id, "8.3(16)", current_node);
  1060.     }
  1061. }
  1062.  
  1063. /* new_agg_or_access becomes two procedures:
  1064.     new_agg_or_access_acc    marker 'access' implied
  1065.     new_agg_or_access_agg    marker 'aggregate' implied
  1066.  */
  1067.  
  1068. void new_agg_or_access_acc(Symbol type_mark)  /*;new_agg_or_access_acc*/
  1069. {
  1070.     /*
  1071.      * The possible types of an aggregate are all composite types that are
  1072.      * currently visible. To simplify their use, an entry  with the marker
  1073.      * 'aggregate' is created for each such type definition. Its overloads
  1074.      * set carries all such types  defined in  the current    scope. This is
  1075.      * similar to what is done for other overloadable constructs.
  1076.      * The same is done for access types, using the marker 'access'.
  1077.      */
  1078.  
  1079.     Symbol    scope, old_def, new_def, maybe_priv, pr;
  1080.     int    nat;
  1081.     Private_declarations pd;
  1082.  
  1083.     if (cdebug2>3) TO_ERRFILE("AT PROC: new_agg_or_access_acc");
  1084.  
  1085.     scope = scope_name;
  1086.     nat = na_access    ;
  1087.     new_def = sym_new(nat);
  1088. #ifdef TBSN
  1089.     new_def = marker + str newat;
  1090. #endif
  1091.     SCOPE_OF(new_def) = scope;
  1092.     TYPE_OF(new_def)  = type_mark;
  1093.     old_def = dcl_get(DECLARED(scope), "access");
  1094.     if (old_def == (Symbol)0 ) {     /* first in scope*/
  1095.         dcl_put(DECLARED(scope), "access", new_def );
  1096.         OVERLOADS(new_def) = set_new1((char *) type_mark);
  1097.     }
  1098.     else {
  1099.         dcl_put(DECLARED(scope), newat_str(), new_def);
  1100.         /* If the current scope is  a private part, make sure the visible
  1101.          * declaration has been saved, before adding new entry to overloads
  1102.          * set for old_def.
  1103.          */
  1104.         pd = (Private_declarations) private_decls(scope);
  1105.         if (NATURE(scope_name) == na_private_part
  1106.           && private_decls_get(pd, old_def) == (Symbol)0)
  1107.             private_decls_put(pd, old_def);
  1108.         OVERLOADS(old_def) = set_with(OVERLOADS(old_def), (char *) type_mark);
  1109.     }
  1110.     /*
  1111.      * If the type has an incomplete private component, (a private ancestor)
  1112.      * list it in the set of private dependents of that ancestor.
  1113.      */
  1114.     maybe_priv =  (Symbol) designated_type(type_mark);
  1115.     pr = private_ancestor(maybe_priv);
  1116.     if ((pr !=(Symbol)0 && in_open_scopes(SCOPE_OF(pr)))
  1117.       || (is_access(type_mark) && is_incomplete_type(pr = maybe_priv)))
  1118.         /* ie still incomplete.*/
  1119.         if (!private_dependents(pr))
  1120.             private_dependents(pr) = set_new1((char *) type_mark);
  1121.         else
  1122.             private_dependents(pr) =
  1123.               set_with(private_dependents(pr), (char *) type_mark);
  1124.     initialize_representation_info(type_mark,TAG_ACCESS);
  1125. }
  1126.  
  1127. void new_agg_or_access_agg(Symbol type_mark)  /*;new_agg_or_access_agg*/
  1128. {
  1129.     /*
  1130.      * The possible types of an aggregate are all composite types that are
  1131.      * currently visible. To simplify their use, an entry  with the marker
  1132.      * 'aggregate' is created for each such type definition. Its overloads
  1133.      * set carries all such types  defined in  the current    scope. This is
  1134.      * similar to what is done for other overloadable constructs.
  1135.      * The same is done for access types, using the marker 'access'.
  1136.      */
  1137.  
  1138.     Symbol    scope, old_def, new_def, maybe_priv, pr;
  1139.     int    nat;
  1140.     Private_declarations pd;
  1141.  
  1142.     scope = scope_name;
  1143.     nat = na_aggregate;
  1144.     new_def = sym_new(nat);
  1145. #ifdef TBSN
  1146.     if (cdebug2>3) TO_ERRFILE("AT PROC: new_agg_or_access_agg");
  1147.     new_def = marker + str newat;
  1148. #endif
  1149.     SCOPE_OF(new_def) = scope;
  1150.     TYPE_OF(new_def)  = type_mark;
  1151.     old_def = dcl_get(DECLARED(scope), "aggregate");
  1152.     if (old_def == (Symbol)0 ) { /* first in scope*/
  1153.         dcl_put(DECLARED(scope), "aggregate", new_def );
  1154.         OVERLOADS(new_def) = set_new1((char *) type_mark);
  1155.     }
  1156.     else {
  1157.         dcl_put(DECLARED(scope), newat_str(), new_def);
  1158.         /* If the current scope is  a private part, make sure the visible
  1159.          * declaration has been saved, before adding new entry to overloads
  1160.          * set for old_def.
  1161.          */
  1162.         pd = (Private_declarations) private_decls(scope);
  1163.         if (NATURE(scope_name) == na_private_part
  1164.           && private_decls_get(pd, old_def) == (Symbol)0)
  1165.             private_decls_put(pd, old_def);
  1166.         /*
  1167.          * Make a copy of the overloads set so that if the field is 
  1168.          * changed it will not affect another copy of the symbol which 
  1169.          * points to this set. This might be the case if we have compilation
  1170.          * units for a package spec and body in the same file. The Overloads
  1171.          * field pointed to by the "aggregate" symbol saved in the unitdecl 
  1172.          * of the spec and restored when processing the body is mangled if
  1173.          * the body adds anything to this overloads field.
  1174.          */
  1175.         OVERLOADS(old_def) = set_copy(OVERLOADS(old_def));
  1176.         OVERLOADS(old_def) = set_with (OVERLOADS(old_def), (char *) type_mark);
  1177.     }
  1178.     /* If the type has an incomplete private component, (a private ancestor)
  1179.      * list it in the set of private dependents of that ancestor.
  1180.      */
  1181.     maybe_priv = type_mark;
  1182.     pr = private_ancestor(maybe_priv);
  1183.     if ((pr !=(Symbol)0 && in_open_scopes(SCOPE_OF(pr)))
  1184.       || (is_access(type_mark) && is_incomplete_type(pr = maybe_priv)))
  1185.         /* ie still incomplete.*/
  1186.         if (!private_dependents(pr))
  1187.             private_dependents(pr) = set_new1((char *) type_mark);
  1188.         else
  1189.             private_dependents(pr) =
  1190.               set_with(private_dependents(pr), (char *) type_mark);
  1191. }
  1192.  
  1193. char *original_name(Symbol unique_nam)     /*;*original_name*/
  1194. {
  1195.     /*
  1196.      * This procedure strips the prefix and suffix of a generated name, to
  1197.      * recover the original source name. Is is used when looking for a
  1198.      * compilation stub, and for error messages.
  1199.      */
  1200.     return ORIG_NAME(unique_nam);
  1201. }
  1202.  
  1203. /*
  1204.  * Process  RENAMES clauses. If the renamed entity is an identifier, then
  1205.  * the renames clause simply creates a synonym : new id shares the symbol
  1206.  * table entry of the  entity. If  the entity  is an expression, then the
  1207.  * interpreter    will have  to elaborate it, and a  'renames' statement is
  1208.  * emitted. In addition, a new symbol table entry  is created for the new
  1209.  * id, with the the appropriate type and nature.
  1210.  */
  1211. void rename_ex(Node node)      /*;rename_ex*/
  1212. {
  1213.     /* Rename an exception.*/
  1214.     Node    id_node, name_node;
  1215.     char    *new_id;
  1216.     Symbol    old;
  1217.  
  1218.     id_node = N_AST1(node);
  1219.     name_node = N_AST2(node);
  1220.     new_id = N_VAL(id_node);
  1221.     adasem(name_node);
  1222.     find_old(name_node);
  1223.     old = N_UNQ(name_node);
  1224.     if (N_KIND(name_node) != as_simple_name) {
  1225.         errmsg("Expect identifier in renaming", "8.5", name_node);
  1226.     }
  1227.     else if (N_OVERLOADED(name_node) || NATURE(old) != na_exception) {
  1228.         errmsg("not an exception", "8.5", name_node);
  1229.     }
  1230.     else
  1231.         dcl_put(DECLARED(scope_name), new_id, old);
  1232. }
  1233.  
  1234. void rename_pack(Node node)  /*;rename_pack*/
  1235. {
  1236.     Node    id_node, name_node;
  1237.     char    *new_id;
  1238.     Symbol    old;
  1239.  
  1240.     id_node = N_AST1(node);
  1241.     name_node = N_AST2(node);
  1242.     new_id = N_VAL(id_node);
  1243.     adasem(name_node);
  1244.     find_old(name_node);
  1245.     old = N_UNQ(name_node);
  1246.     if (N_KIND(name_node) != as_simple_name) {
  1247.         errmsg("Expect identifier in renaming", "8.5", name_node);
  1248.     }
  1249.     else if (N_OVERLOADED(name_node)
  1250.       || (NATURE(old) != na_package
  1251.       &&  NATURE(old) != na_package_spec
  1252.       &&  NATURE(old) != na_generic_package
  1253.       &&  NATURE(old) != na_generic_package_spec)) {
  1254.         errmsg("not a package", "8.5", name_node);
  1255.     }
  1256.     else
  1257.         dcl_put(DECLARED(scope_name), new_id, old);
  1258. }
  1259.  
  1260. void rename_subprogram(Node node)                    /*;rename_subprogram*/
  1261. {
  1262.     /*
  1263.      * The subprogram specification is elaborated, and the declared subpro-
  1264.      * gram is inserted in the symbol table.
  1265.      */
  1266.     Symbol    ret;
  1267.     Node    spec_node, name_node, formal_list;
  1268.     int        kind, s_kind, exists, i;
  1269.     Node    id_node, ret_node;
  1270.     Tuple    formals, ftup, old_types;
  1271.     Symbol    old1;
  1272.     Set        set;
  1273.     Symbol    ne, new_subp, new_ne;
  1274.     Forset    fs1;
  1275.     Fortup    ft1;
  1276.     char    *id;
  1277.  
  1278.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  rename_subprogram");
  1279.  
  1280.     spec_node = N_AST1(node);
  1281.     name_node = N_AST2(node);
  1282.     adasem(spec_node);
  1283.     id_node = N_AST1(spec_node);
  1284.     formal_list = N_AST2(spec_node);
  1285.     ret_node = N_AST3(spec_node);
  1286.     id = N_VAL(id_node);
  1287.     formals = get_formals(formal_list, id);
  1288.  
  1289.     if (N_KIND(spec_node) == as_procedure ) {
  1290.         kind = na_procedure;
  1291.         s_kind = na_procedure_spec;
  1292.         ret = symbol_none;
  1293.         /* Transform into abbreviated as_rename_sub_tr node and reset
  1294.          * N_UNQ(node) in later code below. The spec part of the node
  1295.          * is dropped.
  1296.          */
  1297.         N_KIND(node) = as_rename_sub_tr;
  1298.     }
  1299.     else {
  1300.         kind = na_function;
  1301.         s_kind = na_function_spec;
  1302.         ret = N_UNQ(ret_node);
  1303.         N_KIND(node) = as_rename_sub_tr;
  1304.         /* reset N_UNQ(node) below */
  1305.     }
  1306.     adasem(name_node);
  1307.     find_old(name_node); /* Name of entity being renamed.*/
  1308.  
  1309.     current_node = node;
  1310.     old_types = find_renamed_entity(kind, formals, ret, name_node);
  1311.     if (tup_size(old_types) != 0) {
  1312.         /* the subtypes of the formals are unaffected by the renaming */
  1313.         ret = (Symbol) tup_frome(old_types);
  1314.         FORTUPI(ftup = (Tuple), formals, i, ft1);
  1315.             ftup[3] = (char *)old_types[i];
  1316.         ENDFORTUP(ft1);
  1317.     }
  1318.     else return;        /* previous error. Is this ok ??? */
  1319.  
  1320.     if (N_KIND(name_node) == as_simple_name) {
  1321.         /* renaming of subprogram or operator. */
  1322.         old1 = N_UNQ(name_node);
  1323.         if (in_op_designators(id ))  /* check format, if operator spec */
  1324.             check_new_op(id_node, formals, ret);
  1325.  
  1326.         new_subp = chain_overloads(id, s_kind, ret, formals, old1, OPT_NODE);
  1327.         N_UNQ(node) = new_subp;
  1328.         /* a renaming is both a specification and body */
  1329.         NATURE(new_subp) = kind;
  1330.         if (ALIAS(old1) != (Symbol)0)
  1331.             ALIAS(new_subp) = ALIAS(old1);
  1332.         else
  1333.             ALIAS(new_subp) = old1;
  1334.         if (streq(id , "=")) {
  1335.             if (!streq(original_name(old1) , "=")) {
  1336.                 errmsg("renaming with = can only rename an equality operator",
  1337.                   "6.7", name_node);
  1338.             }
  1339.             else if (tup_size(formals) != 2 ) {
  1340.                 ;    /* error caught elsewhere*/
  1341.             }
  1342.             else {
  1343.                 /* The implicitly defined inequality operator, just introduced,
  1344.                  * renames another inequality.  assert exists ne in
  1345.                  * overloads(declared(scope_of(old1))('/=')) |
  1346.                  *        same_signature(old1, ne);
  1347.                  */
  1348.                 exists = FALSE;
  1349.                 set = OVERLOADS(dcl_get(DECLARED(SCOPE_OF(old1)), "/="));
  1350.                 FORSET(ne=(Symbol), set, fs1);
  1351.                     if(same_signature(old1, ne)) {
  1352.                         exists = TRUE;
  1353.                         break;
  1354.                     }
  1355.                 ENDFORSET(fs1);
  1356.                 if (!exists)
  1357.                     chaos("assertion failed in rename_subprogram chapter 8");
  1358.                 /* assert exists new_ne in
  1359.                  * overloads(declared(scope_of(new_subp))('/=')) |
  1360.                  *      same_signature(new_subp, new_ne);
  1361.                  */
  1362.                 exists = FALSE;
  1363.                 set = OVERLOADS(dcl_get(DECLARED(SCOPE_OF(new_subp)), "/="));
  1364.                 FORSET(new_ne=(Symbol), set, fs1);
  1365.                     if(same_signature(new_subp, new_ne)) {
  1366.                         exists = TRUE;
  1367.                         break;
  1368.                     }
  1369.                 ENDFORSET(fs1);
  1370.  
  1371.                 if (!exists)
  1372.                     chaos("assertion failed in rename_subprogram chapter 8");
  1373.  
  1374.                 if (ALIAS(ne) != (Symbol) 0)
  1375.                     ALIAS(new_ne) = ALIAS(ne);
  1376.                 else
  1377.                     ALIAS(new_ne) = ne;
  1378.             }
  1379.         }
  1380.     }
  1381.     else {
  1382.         /* renaming of entry or attribute. */
  1383.  
  1384.         new_subp= chain_overloads(id, s_kind, ret, formals, (Symbol)0,OPT_NODE);
  1385.         N_UNQ(node) = new_subp;
  1386.     }
  1387.     /* A renaming declaration provides the subprogram specification and the
  1388.      * body as well.
  1389.      */
  1390.     NATURE(new_subp) = kind;
  1391. }
  1392.  
  1393. Tuple find_renamed_entity(int kind, Tuple formals, Symbol ret, Node name_node)
  1394. /*;find_renamed_entity*/
  1395. {
  1396.     /* When a subprogram  is renamed, the  signature of the entity is that of
  1397.      * the renamed object, and not that of the given subprogram specification
  1398.      * (except if the  renamed entity is an operator, in  which case the base
  1399.      * types of the specification are used).
  1400.      * This procedure finds    the renamed  entity (subprogram, entry or attri-
  1401.      * bute, verifies that it matches  the spec, and returns a tuple with the
  1402.      * types of  the formals     of the renamed object, together with  its type.
  1403.      */
  1404.     Symbol    old1, e_name, typ, typ2, res, ft, i;
  1405.     Set        old_sub;
  1406.     Node        e_node, attr_node, typ_node;
  1407.     int        attr;
  1408.     Tuple    tup, ftup;
  1409.     Fortup    ft1;
  1410.     Span        save_span;
  1411.  
  1412.     if (N_OVERLOADED(name_node)) {
  1413.         old_sub = N_NAMES(name_node);        /* Most likely overloadable. */
  1414.         /* find the one that matches the new specification. */
  1415.         old1 = renamed(name_node, formals, ret);
  1416. #ifdef TBSL
  1417.         -- check old1='' in next line
  1418. #endif
  1419.         if (old1 == (Symbol) 0) return tup_new(0);    /* No match found. */
  1420.         else {
  1421.             /* suprogram name renames subprogram name. Mark as simple */
  1422.             /* renaming. */
  1423.             save_span = get_left_span(name_node);
  1424.             ast_clear(name_node);
  1425.             N_KIND(name_node) = as_simple_name;
  1426.             set_span(name_node, save_span);
  1427.             N_UNQ(name_node)  = old1;
  1428.             tup = tup_new(0);
  1429.             if (NATURE(old1) != na_op) {
  1430.                 FORTUP(i=(Symbol), SIGNATURE(old1), ft1);
  1431.                     tup = tup_with(tup, (char *) TYPE_OF(i));
  1432.                 ENDFORTUP(ft1);
  1433.                 tup = tup_with(tup, (char *) TYPE_OF(old1));
  1434.             }
  1435.             else {
  1436.                 FORTUP(ftup=(Tuple), formals, ft1);
  1437.                     tup = tup_with(tup, (char *) base_type((Symbol) ftup[3]));
  1438.                 ENDFORTUP(ft1);
  1439.                 tup = tup_with(tup, (char *) base_type(ret));
  1440.             }
  1441.             return tup;
  1442.         }
  1443.     }
  1444.     else if (kind == na_procedure &&
  1445.       (N_KIND(name_node) == as_selector || N_KIND(name_node)== as_index)) {
  1446.         /* Procedure renames a entry given by a qualified name. Find */
  1447.         /* the full entry (and task) name. */
  1448.         renamed_entry(name_node, formals);
  1449.         e_node = N_AST2(name_node);
  1450.         if (e_node != OPT_NODE) {
  1451.             e_name = N_UNQ(e_node);
  1452. #ifdef TBSL
  1453.             return [type_of(i): i in signature(e_name)] with 'none';
  1454. #endif
  1455.             tup = tup_new(0);
  1456.             FORTUP(i=(Symbol), SIGNATURE(e_name), ft1)
  1457.                 tup = tup_with(tup, (char *) TYPE_OF(i));
  1458.             ENDFORTUP(ft1)
  1459.             tup = tup_with(tup, (char *) symbol_none);
  1460.         }
  1461.         else {
  1462.             return tup_new(0);
  1463.         }
  1464.     }
  1465.     else    {
  1466.         /* The name can be an attribute, renaming a function. */
  1467.         /* Verify that signatures match. */
  1468.         if (kind != na_function || N_KIND(name_node) != as_attribute) {
  1469.             errmsg("invalid renaming", "8.5", name_node);
  1470.             return tup_new(0);
  1471.         }
  1472.         else if (tup_size(formals) != 1) {
  1473.             errmsg("function spec. does not match attribute", "8.5,12.3.6",
  1474.               current_node);
  1475.             return tup_new(0);
  1476.         }
  1477.  
  1478.         attr_node = N_AST1(name_node);
  1479.         typ_node = N_AST2(name_node);
  1480.         attr = (int) N_VAL(attr_node);
  1481.         typ     = N_UNQ(typ_node);
  1482.         tup     = (Tuple) formals[1];     /* verify that this is correct  */
  1483.         ft   = (Symbol)tup[3];
  1484.         /* Find type returned by the attribute, and the required type of its
  1485.          * second argument.
  1486.          */
  1487.  
  1488.         if (attr == ATTR_SUCC || attr == ATTR_PRED) {
  1489.             typ2 = base_type(typ);
  1490.             res = base_type(typ);
  1491.         }
  1492.         else if (attr == ATTR_IMAGE) {
  1493.             typ2 = base_type(typ);
  1494.             res = symbol_string;
  1495.         }
  1496.         else if (attr == ATTR_VALUE) {
  1497.             typ2 = symbol_string;
  1498.             res = base_type(typ);
  1499.         }
  1500.         else {
  1501.             errmsg("attribute cannot be renamed as function", "8.5,12.3.6",
  1502.               attr_node);
  1503.             return tup_new(0);
  1504.         }
  1505.         if (!compatible_types(ret, res) ||
  1506.           !compatible_types(typ2, ft)) {
  1507.             errmsg("function spec. does not match attribute", "8.5,12.3.6",
  1508.               current_node);
  1509.             return tup_new(0);
  1510.         }
  1511.         else {
  1512.             tup = tup_new(2);
  1513.             tup[1] = (char *) typ2;
  1514.             tup[2] = (char *) res;
  1515.             return tup;
  1516.         }
  1517.     }
  1518. }
  1519.  
  1520. void rename_object(Node node)  /*;rename_object*/
  1521. {
  1522.     Node    id_node, type_node, expr_node;
  1523.     char    *new_id;
  1524.     Symbol    typ, new_obj, obj_typ;
  1525.     Node    old_expr = (Node) 0; /* see note below */
  1526.     int    nat;
  1527.     Tuple    tup;
  1528.  
  1529.     if (cdebug2 > 3)
  1530.         TO_ERRFILE("AT PROC :  rename_object");
  1531.  
  1532.     id_node = N_AST1(node);
  1533.     type_node = N_AST2(node);
  1534.     expr_node = N_AST3(node);
  1535.     new_id = N_VAL(id_node);
  1536.     adasem(type_node);
  1537.     adasem(expr_node);
  1538.     find_old(expr_node);
  1539.     typ = find_type(type_node);
  1540.  
  1541.     out_context = TRUE; /* Subcomponents of out parameters*/
  1542.     check_type(typ, expr_node);
  1543.     out_context = FALSE; /* are certainly renamable.*/
  1544.  
  1545.     if (in_qualifiers(N_KIND(expr_node))) {
  1546.         /* Constraints implied by the type mark of the clause are ignored*/
  1547.         expr_node = N_AST1(expr_node);
  1548.         N_AST1(node) = id_node;
  1549.         N_AST2(node) = type_node;
  1550.         N_AST3(node) = expr_node;
  1551.     }
  1552.     /* It is tempting to say that if a simple object is being renamed, the
  1553.      * new one has the same unique name. This simple optimization must
  1554.      * however be delayed until after conformance checks have been done.
  1555.      */
  1556.     /* TBSL - old_expr is never initialized. However
  1557.      * is_discriminant_dependent(12) currently always returns FALSE, so we
  1558.      * just declare old_expr.        ds 3 aug
  1559.      * old_expr is initialized to (Node) 0 to keep lint quite  ds 23-feb-87
  1560.      */
  1561.     if (is_discriminant_dependent( old_expr )) {
  1562.         errmsg_str("existence of object % depends on a discriminant ", new_id,
  1563.           "8.5", (Node)0);
  1564.     }
  1565.     else {
  1566.         new_obj = find_new(new_id);
  1567.         N_UNQ(id_node) = new_obj;
  1568.         tup = check_nat_type(expr_node);
  1569.         nat = (int) tup[1];
  1570.         obj_typ = (Symbol) tup[2];
  1571.         if (N_KIND(expr_node) == as_slice) {
  1572.             obj_typ = slice_type(node,1);
  1573.         }
  1574.         NATURE(new_obj)  = nat;
  1575.         SIGNATURE(new_obj) = (Tuple)expr_node;
  1576.         TYPE_OF(new_obj) = typ;
  1577.         if (N_KIND(expr_node) != as_ivalue) {
  1578.              /* object sharing at run-time. The type is inherited from the
  1579.               * object (the declared type may be unconstrained).
  1580.              */
  1581.             TYPE_OF(new_obj) = obj_typ;
  1582.         /* In the C version constants are allocated and this is handled
  1583.          * during the code generation phase.
  1584.          */
  1585.         }
  1586.     }
  1587. }
  1588.  
  1589. static Symbol renamed(Node name_node, Tuple formals, Symbol ret)    /*;renamed*/
  1590. {
  1591.     Node    arg_list_node, subp_node, arg, expn;
  1592.     Set        sfound, types, nset, tset, subprogs;
  1593.     Symbol    subp, n, t, found;
  1594.     Tuple    arg_list, ftup;
  1595.     Fortup    ft1;
  1596.     Forset    fs1;
  1597.     int        exists;
  1598.  
  1599.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  renamed");
  1600.  
  1601.     /* Find the subprogram in the overloaded set -subprog- which matches
  1602.      * the specification given in a renames clause or in a generic instantia-
  1603.      * tion.
  1604.      * If subprogs includes operators, then the matching is analogous to the
  1605.      * type-checking of an expression. We construct a skeletal argument list
  1606.      * out of the formals, and use result-types(q.v) to find the specific
  1607.      * operator being renamed.
  1608.      */
  1609.     if (cdebug2 > 0) TO_ERRFILE("Renaming prog with signature " );
  1610.  
  1611.     subp_node = copy_tree(name_node);
  1612.     subprogs  = set_new(0);
  1613.  
  1614.     /* The renamed subprogram and the given specification must have the same
  1615.      * parameter and result profile. This requires that signatures have the
  1616.      * same length, and that the types match. Type matching is verified by
  1617.      * constructing a call to the renamed entity. Length checking is done first.
  1618.      */
  1619.     FORSET(subp=(Symbol), N_NAMES(subp_node), fs1)
  1620.         if (NATURE(subp) == na_op
  1621.           || tup_size(SIGNATURE(subp)) == tup_size(formals))
  1622.             subprogs = set_with(subprogs, (char *)subp);
  1623.     ENDFORSET(fs1);
  1624.     N_NAMES(subp_node) = subprogs;
  1625.  
  1626.     arg_list_node = node_new(as_list);
  1627.     arg_list = tup_new(0);
  1628.     FORTUP(ftup=(Tuple), formals, ft1);
  1629.         t = (Symbol) ftup[3];
  1630.         arg = node_new(as_simple_name);
  1631.         N_PTYPES(arg) = set_new1((char *) t);
  1632.         arg_list = tup_with(arg_list, (char *) arg);
  1633.     ENDFORTUP(ft1);
  1634.     N_LIST(arg_list_node) = arg_list;
  1635.  
  1636.     /* Build call node with these arguments, and resolve. */
  1637.     expn = node_new(as_call);
  1638.     N_AST1(expn) = subp_node;
  1639.     N_AST2(expn) = arg_list_node;
  1640.     result_types(expn);
  1641.     types = N_PTYPES(expn);
  1642.     N_PTYPES(expn) = (Set) 0; /* clear */
  1643.     if (types == (Set)0)  types = set_new(0);
  1644.     sfound = set_new(0);
  1645.     if (N_OVERLOADED(subp_node))
  1646.         nset = N_NAMES(subp_node);
  1647.     else
  1648.         nset = (Set) 0;
  1649.     if (nset!=(Set)0) {
  1650.         FORSET(n=(Symbol), nset, fs1);
  1651.             if (compatible_types(TYPE_OF(n), ret))
  1652.                 sfound = set_with(sfound, (char *) n);
  1653.         ENDFORSET(fs1);
  1654.     }
  1655.     /* This may require a stronger test.*/
  1656.     if (set_size(sfound) > 1) {
  1657.         /* user-defined subprogram defined in enclosing scope hides predefined
  1658.           * operator, and is chosen first.
  1659.           */
  1660.         exists = FALSE;
  1661.         FORSET(subp=(Symbol), sfound, fs1);
  1662.             if (NATURE(subp) != na_op
  1663.               && tup_mem((char *) SCOPE_OF(subp) , open_scopes)) {
  1664.                 exists = TRUE;
  1665.                 break;
  1666.             }
  1667.         ENDFORSET(fs1);
  1668.         if (exists) {
  1669.             tset = set_new(0);
  1670.             FORSET(subp=(Symbol), sfound, fs1);
  1671.                 if (NATURE(subp) != na_op)
  1672.                     tset = set_with(tset, (char *) subp);
  1673.             ENDFORSET(fs1);
  1674.             set_free(sfound);
  1675.             sfound = tset;
  1676.         }
  1677.         else {
  1678.             FORSET(subp=(Symbol), sfound, fs1);
  1679.                 if ( NATURE(subp) == na_op) {
  1680.                     sfound = set_new1((char *) subp);
  1681.                     break;
  1682.                 }
  1683.             ENDFORSET(fs1);
  1684.         }
  1685.     }
  1686.     if (set_size(sfound) == 1 ) {
  1687.         found = (Symbol) set_arb( sfound);
  1688.         check_modes(formals, found);
  1689.  
  1690.         if (cdebug2 > 0) TO_ERRFILE("renaming successful with ...");
  1691.  
  1692.         return found;
  1693.     }
  1694.     else if (set_size(sfound) > 1 ) {
  1695.         errmsg_id("ambiguous subprogram name: %", (Symbol) set_arb(subprogs),
  1696.           "8.5,12.3.6", current_node);
  1697.     }
  1698.     else {
  1699.         errmsg("No match for subprogam specification ", "8.5,12.3.6",
  1700.           current_node);
  1701.     }
  1702.     return (Symbol)0;
  1703. }
  1704.  
  1705. static Symbol op_matches_spec(Symbol op_nam, Tuple f_types, Symbol ret)
  1706. /*;op_matches_spec*/
  1707. {
  1708.     /* Determine whether a predefined operator matches a given subprogram
  1709.      * specification. Called for renamings and for name resolution of
  1710.      * selected components whose selector is an operator designator.
  1711.      * The matching is analogous to the type-checking of an expression. We
  1712.      * construct a skeletal argument list out of the type of formals, and
  1713.      * use result-types(q.v) to find the specific operator being renamed.
  1714.      */
  1715.     Node    op_node, arg_list_node, expn;
  1716.     Tuple    arg_list;
  1717.     Symbol    t;
  1718.     Fortup    ft1;
  1719.     Forset  fs1;
  1720.     Set    ops, types;
  1721.     Node    arg;
  1722.  
  1723.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : op_matches_spec");
  1724.  
  1725.     if (tup_size(f_types) < 1 || tup_size(f_types)> 2 )
  1726.         return (Symbol)0;
  1727.     else {
  1728.         op_node = node_new(as_op);
  1729.         N_NAMES(op_node) = set_new1((char *) op_nam);
  1730.         N_OVERLOADED(op_node) = TRUE;
  1731.  
  1732.         arg_list_node = node_new(as_list);
  1733.         arg_list = tup_new(0);
  1734.         FORTUP(t=(Symbol), f_types, ft1);
  1735.             arg = node_new(as_simple_name);
  1736.             N_PTYPES(arg) = set_new1((char *) t);
  1737.             arg_list = tup_with(arg_list, (char *) arg);
  1738.         ENDFORTUP(ft1);
  1739.         N_LIST(arg_list_node) = arg_list;
  1740.  
  1741.         expn = node_new(as_call);
  1742.         N_AST1(expn) = op_node;
  1743.         N_AST2(expn) = arg_list_node;
  1744.         result_types(expn);
  1745.         ops =  (N_OVERLOADED(op_node)) ? N_NAMES(op_node): (Set)0;
  1746.         types = N_PTYPES(expn);
  1747.         N_PTYPES(expn) = (Set)0; /* clear */
  1748.  
  1749.         if (ops == (Set)0) return (Symbol) 0;
  1750.         if (set_size(ops) != 1) return (Symbol) 0;
  1751.         FORSET(t=(Symbol), types, fs1);
  1752.             if (compatible_types(t, ret)) return (Symbol) set_arb(ops);
  1753.         ENDFORSET(fs1);
  1754.         return (Symbol) 0;
  1755.     }
  1756. }
  1757.  
  1758. static void check_modes(Tuple formals, Symbol subp)      /*;check_modes*/
  1759. {
  1760.     /* Verify that the modes of the formals in a renaming spec match the modes
  1761.      * of the renamed subprogram (operator, entry).
  1762.      */
  1763.  
  1764.     int        i, md;
  1765.     Fortup    ft1;
  1766.     Tuple    tup, sig;
  1767.  
  1768.     sig = SIGNATURE(subp);
  1769.     FORTUPI(tup=(Tuple), formals, i, ft1);
  1770.         md = (int) tup[2];
  1771.         if ((NATURE(subp) == na_op && md == na_in)
  1772.           || md == NATURE((Symbol)sig[i]))
  1773.             ;
  1774.         else {
  1775.             errmsg("parameter modes do not match", "8.5(8)", current_node);
  1776.         }
  1777.     ENDFORTUP(ft1);
  1778. }
  1779.  
  1780. static void renamed_entry(Node entry_expr, Tuple formals)     /*;renamed_entry*/
  1781. {
  1782.     /* A procedure is being renamed with an expression. This can only be the
  1783.      * renaming of an entry or a member of an entry family.
  1784.      */
  1785.  
  1786.     Symbol    e, new_typ, i_type;
  1787.     Set entries, found    ;
  1788.     Tuple    tup;
  1789.     Symbol    e_name;
  1790.     Node    task_node, entry_node, index_node;
  1791.     Fortup    ft1;
  1792.     Forset    fs1;
  1793.     Tuple    sig;
  1794.     int    i, nk;
  1795.     Symbol    f;
  1796.  
  1797.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  renamed_entry");
  1798.  
  1799.     find_entry_name(entry_expr);
  1800.     task_node  = N_AST1(entry_expr);
  1801.     entry_node = N_AST2(entry_expr);
  1802.  
  1803.     if (entry_node == OPT_NODE)  /* Invalid entry name or expression*/
  1804.         return;
  1805.     else if (N_KIND(entry_expr) == as_entry_name) {
  1806.         /* possibly  overloaded; disambiguate with signature. */
  1807.         entries = N_NAMES(entry_expr);
  1808.         N_AST3(entry_expr) = OPT_NODE;   /* discard N_NAMES */
  1809.     }
  1810.     else { /* case of entry family member. Type check the index */
  1811.         e_name     = N_UNQ(entry_node);
  1812.         entries    = set_new1((char *) e_name);
  1813.         index_node = N_AST3(entry_expr);
  1814.         i_type     = (Symbol) index_type(TYPE_OF(e_name));
  1815.         check_type(i_type, index_node);
  1816.         N_KIND(entry_expr) = as_entry_name; /* common processing after this*/
  1817.     }
  1818.     found = set_new(0);
  1819.  
  1820.     FORSET(e=(Symbol), entries, fs1);
  1821.         sig = SIGNATURE(e);
  1822.         if (tup_size( sig) != tup_size(formals)) continue;
  1823.  
  1824.         FORTUPI(f =(Symbol), sig, i, ft1);
  1825.             tup = (Tuple) formals[i];
  1826.             new_typ = (Symbol) tup[3];
  1827.             if (!same_type(TYPE_OF(f), new_typ)) goto continue_forall_e;
  1828.         ENDFORTUP(ft1);
  1829.  
  1830.         found = set_with(found, (char *) e);
  1831. continue_forall_e:
  1832.         ;
  1833.     ENDFORSET(fs1);
  1834.  
  1835.  
  1836.     if (set_size(found) != 1 ) {
  1837.         errmsg("ambiguous or invalid entry name in renaming", "8.5", current_node);
  1838.         N_AST1(entry_expr) = OPT_NODE;
  1839.         N_AST2(entry_expr) = OPT_NODE;
  1840.         N_AST3(entry_expr) = OPT_NODE;
  1841.         nk = N_KIND(entry_expr);
  1842.         if (N_AST4_DEFINED(nk)) N_AST4(entry_expr) = (Node)0;
  1843.     }
  1844.     else {
  1845.         /* use entry name to complete resolution of task name*/
  1846.         e_name = (Symbol) set_arb(found);
  1847.         N_UNQ(entry_node) = e_name;
  1848.         complete_task_name(task_node, TYPE_OF(SCOPE_OF(e_name)));
  1849.         check_modes(formals, e_name);
  1850.     }
  1851. }
  1852.  
  1853. Tuple check_nat_type(Node expr_node)     /*;check_nat_type*/
  1854. {
  1855.     /* Obtain the nature and the actual type of of a renamed  expression,
  1856.      * and verify that it designates an object.
  1857.      */
  1858.  
  1859.     Symbol    expn;
  1860.     int        nat, nk;
  1861.     Symbol    t, s;
  1862.     Node    exp1, exp2;
  1863.     int        nrec, nfield;
  1864.     Tuple    tup;
  1865.  
  1866.     if (N_KIND(expr_node) == as_simple_name) {
  1867.         expn = N_UNQ(expr_node);
  1868.         nat = NATURE(expn);
  1869.         t = TYPE_OF(expn);
  1870.         if (nat !=na_constant
  1871.           && nat!= na_in
  1872.           && nat!= na_inout
  1873.           && nat!= na_out
  1874.           && nat!= na_obj) {
  1875.             errmsg("Renamed entity must be an object", "8.5", expr_node);
  1876.         }
  1877.         tup = tup_new(2);
  1878.         tup[1] = (char *) nat;
  1879.         tup[2] = (char *) t;
  1880.         return tup;
  1881.     }
  1882.     else {
  1883.         /* Predefined operation, or call.*/
  1884.         exp1 = N_AST1(expr_node);
  1885.         exp2 = N_AST2(expr_node);
  1886.  
  1887.         nk = N_KIND(expr_node);
  1888.  
  1889.         if (nk == as_index) {
  1890.             /* The nature of an indexed component is the same as the
  1891.              * nature of the array object itself.
  1892.              */
  1893.             tup = check_nat_type(exp1);
  1894.             t = (Symbol) tup[2];
  1895.             tup[2] = (char *) component_type(t);
  1896.             return tup;
  1897.         }
  1898.         else if (nk == as_slice) {
  1899.             /* The nature of the slice is that of the array object.*/
  1900.             return check_nat_type(exp1);
  1901.         }
  1902.         else if (nk == as_selector) {
  1903.             tup = check_nat_type(exp1);
  1904.             nrec = (int) tup[1];
  1905.             s = N_UNQ(exp2);
  1906.             nfield = NATURE(s);
  1907.             t = TYPE_OF(s); /* attrs. of selector */
  1908.             /* IF selector is a discriminant, the new entity must be
  1909.              * treated as such.  Otherwise the  nature of the record
  1910.              * object (constant, formal, etc.) determines that of the
  1911.              * new entity.
  1912.              */
  1913.             nat = (nfield == na_discriminant) ? na_constant : nrec;
  1914.             tup = tup_new(2);
  1915.             tup[1] = (char *) nat;
  1916.             tup[2] = (char *) t;
  1917.             return tup;
  1918.         }
  1919.         else if (nk == as_all) {
  1920.             /* A dereferenced pointer always yields an object.*/
  1921.             tup = check_nat_type(exp1);
  1922.             nat = (int) tup[1];
  1923.             t = (Symbol)tup[2];
  1924.             /*tup_free(tup); may be possible here */
  1925.             tup = tup_new(2);
  1926.             tup[1] = (char *)na_obj;
  1927.             tup[2] =(char *) designated_type(t);
  1928.             return tup;
  1929.         }
  1930.         else if (nk == as_call) {
  1931.             /* The function being called must yield an access type.*/
  1932.             t = N_TYPE(expr_node);
  1933.             if (!is_access(t)) {
  1934.                 errmsg("Renamed entity must be an object", "8.5", expr_node);
  1935.             }
  1936.             tup = tup_new(2);
  1937.             tup[1] = (char *) na_obj;
  1938.             tup[2] = (char *) t;
  1939.             return tup;
  1940.         }
  1941.         else if (nk == as_ivalue) {
  1942.             tup = tup_new(2);
  1943.             tup[1] = (char *) na_constant;
  1944.             tup[2] = (char *) symbol_any;
  1945.             return tup;
  1946.         }
  1947.         else {
  1948.             /*error somewhere.*/
  1949.             tup = tup_new(2);
  1950.             tup[1] = (char *) na_obj;
  1951.             tup[2] = (char *) symbol_any;
  1952.             return tup;
  1953.         }
  1954.     }
  1955. }
  1956.  
  1957. void newscope(Symbol new_name)  /*;newscope*/
  1958. {
  1959.     Tuple    tup;
  1960.     int    old_size;
  1961.     int    i;
  1962.  
  1963.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  newscope");
  1964.     /*
  1965.      * This procedure is invoked when a new lexical scope is entered.
  1966.      * Lexical scopes include package specifications, package bodies ,
  1967.      * subprogram bodies and entry bodies (ACCEPT statements) . In addition
  1968.      * record and task declarations and private parts are treated as scopes.
  1969.      * In each case, the environment of the previous scope is stacked
  1970.      * and the symbol table for the new scope is initialized.
  1971.      */
  1972.     if (cdebug2 > 0)
  1973.         if (ORIG_NAME(new_name) != (char *) 0)
  1974.             printf("new scope %s\n", ORIG_NAME(new_name));
  1975.  
  1976.     tup = tup_new(4);
  1977.     tup[1] = (char *) scope_name;
  1978.     tup[2] = (char *) tup_copy(open_scopes);
  1979.     tup[3] = (char *) tup_copy(used_mods);
  1980.     tup[4] = (char *) tup_copy(vis_mods);
  1981.     scope_st = tup_with(scope_st, (char *) tup);
  1982.     scope_name = new_name;
  1983.  
  1984.     if (DECLARED(scope_name) == (Declaredmap)0) 
  1985.         DECLARED(scope_name) = dcl_new(0);
  1986.  
  1987.     /* save scope_name if new scope      ds 1 aug */
  1988.  
  1989.     /*open_scopes := [scope_name] + open_scopes;*/
  1990.     old_size = tup_size(open_scopes);
  1991.     open_scopes = tup_exp(open_scopes, (unsigned) old_size+1);
  1992.     for (i = old_size; i >= 1; i--)
  1993.         open_scopes[i+1] = (char *) open_scopes[i];
  1994.     open_scopes[1] = (char *) scope_name;
  1995. #ifdef TBSN
  1996. suffix :
  1997.     = str newat;
  1998.     $ For the formation of unique names
  1999. #endif
  2000. }
  2001.  
  2002. void popscope()   /*;popscope*/
  2003. {
  2004.     Tuple    tup;
  2005.  
  2006.     if (cdebug2 > 3)
  2007.         TO_ERRFILE("AT PROC :  popscope");
  2008.     /*
  2009.      * Ths procedure is called on exit from a completed lexical scope.
  2010.      * Eventually , it should contain various housekeeping functions
  2011.      * relating to symbol table statistics and space recovery. For now
  2012.      * it simply restores the environment of the enclosing scope.
  2013.      *
  2014.      * As each scope is closed, a symbol table dump may be done, controled
  2015.      * by the value of cdebug2:
  2016.      *
  2017.      *     cdebug2 = 2  :  show entries for current scope without signature
  2018.      *     cdebug2 > 2  :  show entries for current scope with signature
  2019.      *     cdebug2 > 6  :  show entries for all user defined scopes
  2020.      *     cdebug2 = 9  :  show entries for all declared scopes
  2021.      */
  2022.     if (cdebug2 > 1) {
  2023. #ifdef TBSLN
  2024.         loop forall scop in
  2025.             if cdebug2 = 9 then domain declared
  2026.         elseif cdebug2 > 6 then domain(declared) -
  2027.             ({
  2028.             'STANDARD#0', 'UNMENTIONABLE#0', 'ASCII'        }
  2029.         +
  2030.             {
  2031.             x(2) :
  2032.             x in PREDEF_UNITS        }
  2033.         )
  2034. else {
  2035.     scope_name}
  2036. end
  2037. do
  2038. sig_flag :
  2039.     = (cdebug2 > 2) and
  2040.         exists [item, u_name] in DECLARED(scop) |
  2041.         SIGNATURE(u_name) /= om;
  2042. errstr "--- Symbol table entries for declared("+scop+"):";
  2043. TO_ERRFILE(errstr );
  2044. errstr = rpad("Id", 15) + rpad("Unique name", 25) +
  2045. rpad("Nature", 15) + rpad("Type", 24) +
  2046. if sig_flag then " Signature" else "" end;
  2047. TO_ERRFILE(errstr );
  2048. (forall [item, u_name] in DECLARED(scop))
  2049. line :
  2050. = rpad(item ? "", 14);
  2051. line := rpad(line + " " + u_name ? "", 39);
  2052. line := rpad(line + " " + nature(u_name) ? "", 54);
  2053. line := rpad(line + " " +
  2054. if is_string(type_of(u_name)) then type_of(u_name)
  2055. else str type_of(u_name) end, 79);
  2056. if sig_flag and signature(u_name) /= om then
  2057. line +:
  2058. = " " + str signature(u_name);
  2059. end if;
  2060. TO_ERRFILE(line);
  2061. line :
  2062. =  str (overloads(u_name)) + " "
  2063. + str scope_of(u_name)    + " "
  2064. + str alias(u_name);
  2065. TO_ERRFILE(line);
  2066.  
  2067. end forall;
  2068. end loop;
  2069. #endif
  2070.     }
  2071.     tup = (Tuple) tup_frome(scope_st);
  2072.     scope_name = (Symbol) tup[1];
  2073.     open_scopes = (Tuple) tup[2];
  2074.     used_mods = (Tuple) tup[3];
  2075.     vis_mods = (Tuple) tup[4];
  2076.     if (cdebug2 > 0) TO_ERRFILE("return to scope: " );
  2077. }
  2078.  
  2079. void newmod(char *name)   /*;newmod*/
  2080. {
  2081.     Symbol    new_name;
  2082.  
  2083.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  newmod");
  2084.  
  2085.     /* Update this comment*/
  2086.  
  2087. #ifdef SKIPTHIS
  2088.     -- I think all we need is find_new call
  2089.         if (IS_COMP_UNIT){
  2090.         /* TBSN- SETL has new_name := name. But in C, name is string, and
  2091.    new_name is symbol table pointer. Try replacing with find_new
  2092.     new_name = name;
  2093.  */
  2094.         new_name = find_new(name);
  2095.         /* Enter module name in STANDARD*/
  2096.         if (dcl_get(DECLARED(scope_name), name) == (Symbol)0) {
  2097.             dcl_put(DECLARED(scope_name), name, new_name);
  2098.             SCOPE_OF(new_name) = scope_name;
  2099.             TO_XREF(new_name);
  2100.         }
  2101.         else {
  2102.             errmsg_str("Duplicate declaration of %", name , "8.3", current_node);
  2103.         }
  2104.     }
  2105.     else {
  2106.         new_name = find_new(name);
  2107.     }
  2108. #endif
  2109.     new_name = find_new(name);
  2110.     ORIG_NAME(new_name) = strjoin(name, "");
  2111.     /* Initialize its symbol table and enter scope.  */
  2112.     DECLARED(new_name) = dcl_new(0);
  2113.     /*declared(new_name) := visible(new_name) := {};*/
  2114.     newscope(new_name);
  2115.     /* and update prefix of names with current module name. */
  2116. #ifdef TBSN
  2117.     prefix = prefix + name + '.';
  2118. #endif
  2119. }
  2120.  
  2121. void use_clause(Node node)                    /*;use_clause*/
  2122. {
  2123.     /* If the use clause appears within a package specification, it constitutes
  2124.      * a declarative item that is visible in the corresponding body, and must
  2125.      * be saved in the declared map of the package.
  2126.      */
  2127.  
  2128.     Node    id_node;
  2129.     char    *id;
  2130.     Symbol    rnam, uds, un;
  2131.     Fortup    ft1;
  2132.     Fordeclared fd;
  2133.     int     nat;
  2134.  
  2135.     nat = NATURE(scope_name);
  2136.     if (nat == na_package_spec || nat == na_generic_package_spec
  2137.       || nat == na_private_part)
  2138.         /*use_declarations(scope_name) +:= used;*/
  2139.         uds = dcl_get(DECLARED(scope_name), "$used");
  2140.     else uds = (Symbol)0;
  2141.  
  2142.     FORTUP(id_node =(Node), N_LIST(node), ft1);
  2143.         id = N_VAL(id_node);
  2144.         check_old(id_node);
  2145.         rnam = N_UNQ(id_node);
  2146.         if (rnam == symbol_undef) {
  2147.             errmsg_str("undeclared package name %", id, "8.4, 10.1", id_node);
  2148.         }
  2149.         else if (N_OVERLOADED(id_node) ||
  2150.           NATURE(rnam)!=na_package && NATURE(rnam) !=na_package_spec){
  2151.             errmsg_str("% is not the name of a USEable package", id,
  2152.               "8.4", id_node);
  2153.         }
  2154.         else {
  2155.             if (!tup_mem((char *) rnam, used_mods))
  2156.                 used_mods = tup_with(used_mods, (char *) rnam);
  2157.             /* inner packages defined in a 'used' package can now be used to
  2158.                * qualify their inner entities
  2159.                */
  2160.             if (DECLARED(rnam) != (Declaredmap)0) { /* in case of error */
  2161.                 FORDECLARED(id, un, DECLARED(rnam), fd);
  2162.                     if (IS_VISIBLE(fd) && (NATURE(un) == na_package
  2163.                       || NATURE(un) == na_package_spec))
  2164.                         vis_mods = tup_with(vis_mods, (char *) un);
  2165.                 ENDFORDECLARED(fd);
  2166.             }
  2167.             if (uds != (Symbol)0)
  2168.                 SIGNATURE(uds) = tup_with(SIGNATURE(uds), (char *)rnam);
  2169.         }
  2170.     ENDFORTUP(ft1);
  2171. }
  2172.